COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 blocks.lsp[f83,jmc]	LISP block stacking program
C00008 ENDMK
C⊗;
;;; blocks.lsp[f83,jmc]	LISP block stacking program

;;; The main function is  (result action situation)  which acts as a kind
;;; of interpreter of actions.  A situation is a pair  (s1.moves)  where
;;; s1  is a structure, i.e. a list of towers, where a tower is a list of
;;; blocks.  moves  is a list of pairs the first element of which is a
;;; block and the second is either a block or 'table.  Each pair represents
;;; the elementary action of moving the first element to the second element.
;;; The main action has the form  ('build1 s1),  where  s1  is a structure.
;;; (result ('build1 s1) s)  is a new situation that results from building
;;; the structure  s1  in the situation  s.  Here are the other actions

;;; ('build tower) - builds the tower in question
;;; ('move1 b1 b2) - moves b1 onto b2 if it isn't there already
;;; ('move b1 b2) - moves b1 onto b2 assuming it isn't there already
;;; ('clear b) - clears the block b by moving things onto the table
;;; ('immove b1 b2) - moves b1 to b2 assuming both blocks are clear

(defun result (a s)
       (cond
	((eq (car a) 'build1)
	 (if (null (cadr a)) s (result (list 'build1 (cdadr a))
				       (result (list 'build (reverse (caadr a))
						     'table)
					       s))))
	((eq (car a) 'build)
	 (if (null (cadr a))
	     s
	     (result (list 'build (cdadr a) (caadr a))
		     (result (list 'move1 (caadr a) (caddr a)) s))))
	((eq (car a) 'move1)
	 (if (on (cadr a) (caddr a) (car s)) 
	     s
	     (result (list 'move (cadr a) (caddr a)) s)))
	((eq (car a) 'move)
	 (result (list 'immove (cadr a) (caddr a))
		 (result (list 'clear (caddr a))
			 (result (list 'clear (cadr a)) s))))
	((eq (car a) 'immove)
	 (cons (update (car s) (cdr a)) (cons (cdr a) (cdr s))))
	((eq (car a) 'clear)
	 (if (null (cadr a))
	     s
	     (clear (cadr a) (clear1 (cadr a) (car s)) s)))))

(defun update1 (s1 pair)
       (cond
	((or (null s1) (and (null (car pair)) (null (cadr pair))))
	 s1)
	((eq (caar s1) (car pair))
	 (cons (cdar s1) (update1 (cdr s1) pair)))
	((eq (caar s1) (cadr pair))
	 (cons (cons (car pair) (car s1))
	       (update1 (cdr s1) (list (car pair) nil))))
	(t
	 (cons (car s1) (update1 (cdr s1) pair)))))

(defun update (s1 pair)
       (update2 (if (eq (cadr pair) 'table)
		    (cons (list (car pair)) (update1 s1 (cons (car pair) nil)))
		    (update1 s1 pair))))

(defun update2 (s1) (cond
		     ((null s1) nil)
		     ((null (car s1)) (cdr s1))
		     (t (cons (car s1) (update2 (cdr s1))))))

(defun clear1 (b s1) (if (member b (car s1)) (car s1) (clear1 b (cdr s1))))

(defun clear (b tower s)
       (if (eq b (car tower))
	   s
	   (clear b (cdr tower) (result (list 'immove (car tower) 'table) s))))

(defun on (a b s1) (on1 a b (clear1 a s1)))
       
(defun on1 (a b tower)
       (and (not (null tower))
	    (or (and (eq (car tower) a)
		     (or (and (eq b 'table) (null (cdr tower)))
			 (and (not (null (cdr tower))) (eq (cadr tower) b))))
		(on1 a b (cdr tower)))))

;;; tests
(setq t1 '((a b) (c)))
(setq t2 '((a b c)))
(setq s0 (cons t1 nil))
(setq tt0 '(b c))
(result '(immove a c) s0)
(result '(move a c) s0)
(result '(move1 a c) s0)
(result '(immove a table) s0)
(result '(build (c) a) s0)
(result '(build (c b) table) s0)
(result (list 'build1 t2) s0)
(setq t3 '((a b c) (d e) (f)))
(setq t4 '((a b c d f) (e)))
(result (list 'build1 t4) (cons t3 nil))